/* Definitions for the bytecode compiler.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include <cstdlib>
#include <cstdio>
#include <climits>
#include <vector>
#include "khipu.hpp"
#include "utils/sorted_list.hpp"
#include "utils/raw_acc.hpp"

KP_DECLS_BEGIN

// Special instruction used to refer to labels in the code.
static const int OP_LABEL = 0x100;

#define OPX_(opc)   (EXTRA_BIT | (fixint ((int)OP_##opc)))

/* Opcodes that follow OP_VARGC are defined as pairs, the second one being
 * the 'long' form. This means that computing the long form of an instruction
 * is very simple. */
static object
make_lform (object inst)
{
  return ((inst & ~EXTRA_BIT) + (fixint (1) | EXTRA_BIT));
}

struct xcmp_call
{
  interpreter *ip;

  int operator() (intptr_t left, intptr_t right) const
    {
      auto i1 = itype (left), i2 = itype (right);
      if (i1 == i2)
        {
          auto rv = xcmp (this->ip, (object)left, (object)right);
          if (!rv.error_p ())
            return (deref (rv));

          this->ip->reset_exc ();
        }

      return ((int)(i1 - i2));
    }
};

struct whl_block
{
  int top_lbl;
  int end_lbl;
  int stkpos;
  uint32_t exc_cnt;
  uint32_t n_dbinds;
  whl_block *next;
};

struct bitmap
{
  raw_acc<array> bmap;
  size_t nelem;
  static const uint32_t NBITS = sizeof (uintptr_t) * 8;

  bitmap () : bmap (1)
    {
      *this->ptr() = 0;
      this->nelem = 0;
    }

  uint32_t& len ()
    {
      return (this->bmap.ptr->len_ref ());
    }

  object* ptr ()
    {
      return (this->bmap.ptr->data_ptr ());
    }

  void expand (uint32_t nl)
    {
      this->bmap.expand (nl);
      if (nl > this->len ())
        {
          memset (this->ptr () + this->len (), 0, (nl - this->len ()) * 8);
          this->len() = nl;
        }
    }

  bool set (uintptr_t bit)
    {
      uint32_t idx = (uint32_t)(bit / NBITS + 1);
      this->expand (idx);
      if (this->ptr()[--idx] & (uintptr_t)1 << (bit % NBITS))
        return (false);

      this->ptr()[idx] |= (uintptr_t)1 << (bit % NBITS);
      ++this->nelem;
      return (true);
    }

  bool get (uintptr_t bit)
    {
      uint32_t idx = (uint32_t)(bit / NBITS);
      if (idx > this->len ())
        return (false);

      return ((this->ptr()[idx] & ((uintptr_t)1 << (bit % NBITS))) != 0);
    }
};

/* The bytecode compiler receives an expression read from a stream and
 * produces a bvector that can be executed by the interpreter. Compilation is
 * split into several passes:
 *
 * - Macro expansion: The original expression is recursively expanded, but
 * only at the outermost level.
 *
 * - Symbolic code generation: After the outermost form has been expanded,
 * the compiler generates the instructions defined by the OPX_ macros, and
 * does some piecemeal optimizations here and there. Every inner form is
 * macroexpanded before being compiled.
 *
 * - Bytecode output: The symbolic instructions are transformed into bytecode.
 * Depending on the size, long versions of the instructions may be emitted.
 *
 * - Label fixing: With the bytecode finished, the placeholders used as labels
 * are replaced by correct offsets.
 */

struct bc_compiler
{
  enum
    {
      flg_toplevel    = 0x01,
      flg_warnings    = 0x02,
      flg_incatch     = 0x04
    };

  struct frame_data
    {
      int nargs = 0;
      int stkdisp = 0;
      int acc = 0;
      size_t *ipp = nullptr;
      frame_data *next = nullptr;
    };

  struct whl_handler
    {
      bc_compiler& bc;

      whl_handler (bc_compiler& ebc, whl_block *wp) : bc (ebc)
        {
          this->bc.push_whl (wp);
        }

      ~whl_handler ()
        {
          this->bc.pop_whl ();
        }
    };

  struct frame_vec
    {
      frame_data *head = nullptr;
      int size = 0;

      void push (const frame_data& fd)
        {
          frame_data *f = (frame_data *)xmalloc (sizeof (*f));
          *f = fd;
          f->next = this->head;
          this->head = f;
          ++this->size;
        }

      void pop ()
        {
          frame_data *top = this->head;
          this->head = top->next;
          xfree (top);
          --this->size;
        }

      frame_data& top ()
        {
          return (*this->head);
        }

      const frame_data& top () const
        {
          return (*this->head);
        }

      frame_data& operator[] (int ix)
        {
          frame_data *runp = this->head;
          for (int i = this->size - ix - 1; i > 0; --i, runp = runp->next) ;
          return (*runp);
        }

      ~frame_vec ()
        {
          for (auto runp = this->head; runp; )
            {
              auto tmp = runp->next;
              xfree (runp);
              runp = tmp;
            }
        }
    };

  typedef sorted_list<xcmp_call> ctable_t;
  typedef std::vector<object> codevec_t;

  sp_guard spg;
  interpreter *interp;
  ctable_t ctable;
  codevec_t code;
  int lbl_cnt = 0;
  raw_acc<bvector> bytecode;
  object ct_env;
  struct
    {
      cons expr;
      symbol sym;
      string name;
      unsigned char sn[2];
    } xdo;

  whl_block *whl = nullptr;
  frame_vec frames;
  uint32_t rflags = 0;
  uint32_t exc_depth = 0;
  uint32_t n_dbinds = 0;
  int min_argc;
  int max_argc;
  object ldargs[4];
  bc_compiler *bprev = nullptr;
  bitmap captures;
  sorted_list<> capt_idx;

  bc_compiler (interpreter *ip, uint32_t iflags = 0) :
      spg (ip), interp (ip), bytecode (16)
    {
      this->xdo.expr.car = UNBOUND;
      this->ct_env = NIL;
      this->ctable.cmp.ip = ip;
      this->rflags |= iflags;
      this->ldargs[0] = this->ldargs[1] = this->ldargs[2] = UNBOUND;

      frame_data fr;
      fr.stkdisp = interpreter::frame_size;
      this->frames.push (fr);
    }

  struct insertp_handler
    {
      bc_compiler *bp;
      size_t ipoint;
      size_t f0;
      size_t f1;

      insertp_handler (bc_compiler& b) : bp (&b)
        {
          this->ipoint = this->bp->code.size ();
          this->f0 = this->f1 = this->bp->frames.size - 1;
          bool got = false;

          while (true)
            {
              auto& fr = this->bp->frames[this->f0];
              if (fr.ipp)
                break;

              fr.ipp = &this->ipoint;
              got = true;
              if (!this->f0)
                break;

              --this->f0;
            }

          if (!got)
            this->bp = nullptr;
          else
            ++this->f1;
        }

      ~insertp_handler ()
        {
          if (!this->bp)
            return;

          for (; this->f0 < this->f1; ++this->f0)
            this->bp->frames[this->f0].ipp = nullptr;
        }
    };

  int cur_stkpos () const
    {
      const auto& f = this->frames.top ();
      return (f.acc + f.nargs + f.stkdisp);
    }

  void push_f ()
    {
      frame_data fr;
      fr.acc = this->cur_stkpos ();
      this->frames.push (fr);
    }

  void pop_f ()
    {
      this->frames.pop ();
    }

  frame_data& cur_f ()
    {
      return (this->frames.top ());
    }

  int next_label ()
    { // Return a symbolic value for the next label.
      return (this->lbl_cnt++);
    }

  void mark_label (int lbl)
    {
      this->code.push_back (OPX_(LABEL));
      this->code.push_back (fixint (lbl));
    }

  void push_whl (whl_block *wp)
    {
      wp->top_lbl = this->next_label ();
      wp->end_lbl = this->next_label ();
      wp->stkpos = this->cur_stkpos ();
      wp->exc_cnt = this->exc_depth;
      wp->n_dbinds = this->n_dbinds;
      wp->next = this->whl;
      this->whl = wp;
    }

  void pop_whl ()
    {
      this->whl = this->whl->next;
    }

  int index (object val)
    {
      auto np = this->ctable.add (val);
      if (np->val == -1)
        np->val = this->ctable.len () - 1;

      return ((int)np->val);
    }

  object idxvec (object out)
    {
      for (ctable_t::iterator it (this->ctable); it.valid (); ++it)
        xaref(out, it.val ()) = it.key ();

      as_array(out)->len = this->ctable.len ();
      as_array(out)->vo_full |= array::nonref_flag;
      return (out);
    }

  result<object> idxvec ()
    {
      object ret = KP_TRY (alloc_array (this->interp, this->ctable.len ()));
      if (this->ctable.len ())
        this->idxvec (ret);

      return (ret);
    }

  cons* expr_do ()
    {
      if (this->xdo.expr.car != UNBOUND)
        return (&this->xdo.expr);

      this->xdo.sn[0] = 'd';
      this->xdo.sn[1] = 'o';

      this->xdo.name.vo_type = typecode::STR;
      this->xdo.name.data = this->xdo.sn;
      this->xdo.name.len = this->xdo.name.nbytes = 2;

      this->xdo.sym.vo_type = typecode::SYMBOL;
      this->xdo.sym.name = this->xdo.name.as_obj ();
      this->xdo.sym.value = this->xdo.sym.pkg = UNBOUND;

      this->xdo.expr.car = this->xdo.sym.as_obj ();
      this->xdo.expr.cdr = NIL;

      return (&this->xdo.expr);
    }

  int bc_len () const
    {
      return (as_bvector(this->bytecode.as_obj ())->nbytes);
    }

  template <typename T>
  void bytecode_write (T code)
    {
      this->bytecode.add_data (&code, sizeof (code));
    }

  void emit (object inst, object *argp, int nargs);

  template <typename ...Args>
  void emit (object inst, Args... args)
    {
      object lst[] = { args..., 0};
      this->emit (inst, lst, (int)KP_NELEM (lst) - 1);
    }

  void restore_exc (uint32_t n)
    {
      for (; n; --n)
        this->emit (OPX_(TRYEND));
      if (this->rflags & flg_incatch)
        this->emit (OPX_(CLREXC));
    }

  void unwind_state (whl_block *wlp)
    {
      this->restore_exc (this->exc_depth - wlp->exc_cnt);
      if (this->n_dbinds > wlp->n_dbinds)
        this->emit (OPX_(UNBIND), fixint (this->n_dbinds - wlp->n_dbinds));

      uint32_t diff = this->cur_stkpos () - wlp->stkpos;
      if (diff > 0)
        this->emit (OPX_(SKIP), fixint (diff));
    }

  void erase (codevec_t::iterator it)
    {
      this->code.erase (it);
      this->ldargs[0] = UNBOUND;
    }

  void erase (codevec_t::iterator i1, codevec_t::iterator i2)
    {
      this->code.erase (i1, i2);
      this->ldargs[0] = UNBOUND;
    }

  bvector* encode (bool release);
  object encode ();

  struct operation_set
    {
      object local;
      object closure;
      object global;
      object boxed;
      object dynamic;
      bool write;
    };

  result<int> compile_sym (object env, bool tail, object s,
                           const operation_set& ops);

  result<int> compile_atom (object env, bool tail, object expr,
                            bool quoted = false);

  result<int> compile_cond (object env, bool tail,
                            object expr, bool popa = true);

  result<int> compile_if (object env, bool tail, object expr);
  result<int> compile_do (object env, bool tail, object forms);
  result<int> compile_while (object env, object cond, object body);
  result<int> compile_short_circuit (object env, bool tail, object forms,
                                     object dfl, object branch);

  result<int> compile_and (object env, bool tail, object forms)
    {
      return (this->compile_short_circuit (env, tail, forms,
                                           symbol::t, OPX_(JMPN)));
    }

  result<int> compile_or (object env, bool tail, object forms)
    {
      return (this->compile_short_circuit (env, tail, forms,
                                           NIL, OPX_(JMPT)));
    }

  result<int> compile_arglist (object env, object expr,
                               int off = 1, int nmax = INT_MAX);

  result<int> compile_app (object env, bool tail, object expr);
  result<bool> compile_seq (object env, bool tail, object expr);
  result<void> compile_try (object env, bool tail, object expr);
  result<int> compile_in (object env, bool tail, object expr);
  result<void> emit_optargs_init (object env, object opta, object vars, int idx);

  result<object> compile_fct (object env, object expr);
  result<object> compile_fct_body (object env, object expr, uint32_t flags = 0);
  result<int> compile_let (object env, bool tail, object expr);

  int last_idx () const
    {
      for (int i = (int)this->code.size () - 1; i >= 0; --i)
        if ((this->code[i] & EXTRA_BIT) && this->code[i] != OPX_(LABEL))
          return (i);

      return (-1);
    }

  result<void> warn_helper (stream *sp, object msg)
    {
      KP_VTRY (sp->write (this->interp, ";; warning: ", 12),
               sp->write (this->interp, str_cdata (msg), as_str(msg)->nbytes),
               sp->write (this->interp, "\n\n", 2),
               sp->flush (this->interp));
      return (0);
    }

  void test_nargs_fct (object obj, object env, int nargs);
};

#define BC_WARN(Comp, ...)   \
    do   \
      {   \
        auto pm = KP_SPRINTF ((Comp).interp, __VA_ARGS__);   \
        if (!pm.error_p ())   \
          {   \
            valref msg ((Comp).interp, deref (pm));   \
            stream *sp = as_stream (err_stream);   \
            if (sp->io_flags & STRM_NOLOCK)   \
              deref ((Comp).warn_helper (sp, *msg));   \
            else   \
              {   \
                lock_guard g ((Comp).interp, as_lock (sp->ilock));   \
                deref ((Comp).warn_helper (sp, *msg));   \
              }   \
          }   \
      }   \
    while (false)

static bool
equal_opcodes (object i1, const object *p1, const object *p2, int n)
{
  if (i1 != *p2++)
    return (false);

  for (int i = 0; i < n; ++i)
    if (*p1++ != *p2++)
      return (false);

  return (true);
}

struct ldarg_reset
{
  object* dstp;

  ldarg_reset (object *head) : dstp (head) {}

  ~ldarg_reset ()
    {
      if (this->dstp)
        *this->dstp = UNBOUND;
    }
};

void bc_compiler::emit (object inst, object *argp, int nargs)
{
  auto& cv = this->code;
  ldarg_reset lr (&this->ldargs[0]);

  if (inst == OPX_(CAR) && !cv.empty () && cv.back () == OPX_(CDR))
    { // Transform (car (cdr $expr)) into (cadr $expr)
      cv.back() = OPX_(CADR);
      return;
    }
  else if (cv.size () >= 2 && make_lform (cv[cv.size () - 2]) == OPX_(SKIPL))
    {
      if (inst == OPX_(RET))
        { // Remove unnecessary 'skip' if it's followed by a ret.
          cv.erase (cv.end () - 2);
          cv.back() = inst;
          return;
        }
      else if (make_lform (inst) == OPX_(SKIPL))
        { // Condense multiple 'skip' forms into a single one.
          if (as_int (cv.back () += *argp) > 0xff)
            cv[cv.size () - 2] = OPX_(SKIPL);
          return;
        }
    }
  else if (inst == OPX_(RET) && !cv.empty () && cv.back () == inst)
    // Redundant 'ret'.
    return;

  if (inst == OPX_(POP) && cv.size () >= 2)
    {
      if (make_lform (cv[cv.size () - 2]) == OPX_(SETAL))
        {
          cv[cv.size () - 2] += fixint (OP_SETAPOP - OP_SETA);
          return;
        }
      else
        {
          int ix = this->last_idx ();
          if (ix >= 0 && (cv[ix] == OPX_(LOADT) || cv[ix] == OPX_(LOADNIL)))
            {
              if (ix >= 4 && cv[ix - 2] == OPX_(LABEL) &&
                  cv[cv.size () - 2] == cv[ix - 2] &&
                  bcode_get(as_int (cv[ix - 4]))->branch_p () &&
                  cv[ix - 3] == cv[ix + 2])
                { /* Common pattern:
                   *     branch L1
                   *     ...
                   *     jmp L2
                   * L1: loadnil
                   * L2: pop
                   *     ...
                   *
                   * Such bytecode can be generated by non-tail 'if' forms
                   * without an 'else' clause. We optimize by rearranging
                   * the label L1 to point forward and avoid the redundant
                   * loadnil+pop instruction:
                   *
                   *     branch L1
                   *     ...
                   *     pop
                   * L1: ...
                   */
                  int lbl = as_int (cv[ix - 1]);
                  cv.erase (cv.begin () + ix - 2, cv.begin () + ix + 1);
                  this->emit (OPX_(POP));
                  this->mark_label (lbl);
                }
              else
                // Eliminate the loadK+pop sequence.
                cv.erase (cv.begin () + ix);

              return;
            }
        }
    }
  else if (inst == OPX_(LOADV) || inst == OPX_(LOADG) ||
      inst == OPX_(SETG) || inst == OPX_(LOADX) || inst == OPX_(BIND))
    *argp = fixint (this->index (*argp));

  {
    const bcode_instr *instrp = bcode_get (as_int (inst) + 1);
    if (instrp->long_p ())
      for (int ix = 0; ix < instrp->nops (); ++ix)
        if ((inst == OPX_(LOADI8) && (as_int (argp[ix]) >= 0x80 ||
                                      as_int (argp[ix]) < -128)) ||
            as_int (argp[ix]) > 0xff)
          {
            inst = make_lform (inst);  // Convert to long form.
            break;
          }
  }

  // Try to optimize load instruction.
  if (inst == OPX_(LOADA) && as_int (*argp) <= 1)
    {
      nargs = 0;
      inst = *argp == fixint (0) ? OPX_(LOADA0) : OPX_(LOADA1);
    }
  else if (inst == OPX_(LOADC) && as_int (*argp) == 0)
    {
      if (as_int (argp[1]) <= 1)
        {
          nargs = 0;
          inst = argp[1] == fixint (0) ? OPX_(LOADC00) : OPX_(LOADC01);
        }
      else
        {
          nargs = 1;
          *argp = argp[1];
          inst = OPX_(LOADC0);
        }
    }
  else if (inst == OPX_(SETC) && as_int (*argp) == 0)
    {
      nargs = 1;
      *argp = argp[1];
      inst = OPX_(SETC0);
    }

  object lasti = cv.empty () ? UNBOUND : cv.back ();

  // Try to optimize branching instruction.
  if (inst == OPX_(BRN))
    {
      if (lasti == OPX_(NOT))
        {
          if (cv.size () > 2 && cv[cv.size () - 2] == lasti)
            {
              cv.pop_back ();
              cv.back() = OPX_(BRN);
            }
          else
            cv.back() = OPX_(BRT);

          cv.push_back (*argp);
        }
      else if (lasti == OPX_(IS))
        {
          cv.back() = OPX_(BRNEQ);
          cv.push_back (*argp);
        }
      else
        {
          cv.push_back (inst);
          cv.push_back (*argp);
        }
    }
  else if (inst == OPX_(BRT) && lasti == OPX_(NOT))
    {
      cv.back() = OPX_(BRN);
      cv.push_back (*argp);
    }
  else
    {
      lr.dstp = nullptr;

      if (bcode_get(as_int (inst))->loadf_p () && (nargs > 0 ||
          inst == OPX_(LOADC00) || inst == OPX_(LOADC01)) &&
          equal_opcodes (inst, argp, this->ldargs, nargs))
        {
          cv.push_back (OPX_(DUP));
          return;
        }

      cv.push_back (inst);
      for (int i = 0; i < nargs; ++i)
        cv.push_back (argp[i]);

      this->ldargs[0] = inst;
      copy_objs (this->ldargs + 1, argp, nargs);
    }
}

static inline int
label_get (bool large, const uint8_t *ip)
{
  return (large ? get32 (ip) : (int16_t)get16 (ip));
}

static inline int
label_size (bool large)
{
  return (large ? sizeof (int32_t) : sizeof (int16_t));
}

static inline void
label_put (bool large, uint8_t *ip, uint32_t val)
{
  if (large)
    put32 (ip, val);
  else
    put16 (ip, val);
}

static int
lastjmp (const uint8_t *ip, int off, bool large, int first)
{
  for (int ijmp = large ? OP_JMPL : OP_JMP ; ; )
    {
      int opc = ip[off];
      if (opc == ijmp || opc == first)
        off += label_get (large, &ip[off + 1]) + 1;
      else
        break;
    }

  return (off);
}

static void
condense_jmps (bvector *bvp, sorted_list<>& fixup, bool large)
{
  for (sorted_list<>::iterator it (fixup); it.valid (); ++it)
    {
      int off = it.key () + label_get (large, &bvp->data[it.key ()]);
      int first = bvp->data[it.key () - 1];

      if (first != OP_JMPT && first != OP_JMPTL &&
          first != OP_JMPN && first != OP_JMPNL)
        first = -1;   // Any non-opcode will do.

      int npos = lastjmp (bvp->data, off, large, first);

      if (npos != off)
        label_put (large, bvp->data + it.key (), npos - it.key ());
    }
}

static void
remove_jmp (bvector *bvp, sorted_list<>& fixup,
            int pos, int len, bool large)
{
  for (sorted_list<>::iterator it (fixup); it.valid (); ++it)
    {
      int lbl = it.key (), off = label_get (large, &bvp->data[lbl]);

      if (lbl < pos && lbl + off > pos)
        label_put (large, bvp->data + lbl, off - len);
      else if (lbl > pos)
        {
          it.key() -= len;
          if (lbl + off < pos)
            label_put (large, bvp->data + lbl, off + len);
        }
    }

  memmove (bvp->data + pos, bvp->data + pos + len, bvp->nbytes - pos - len);
  bvp->nbytes -= len;
}

static void
simplify_jmps (bvector *bvp, sorted_list<>& fixup, bool large)
{
  uint8_t *ip = bvp->data;

  for (sorted_list<>::iterator it (fixup); it.valid (); )
    {
      int opc = ip[it.key () - 1];
      if (opc != OP_JMP && opc != OP_JMPL)
        {
          ++it;
          continue;
        }

      const int sz = label_size (large);
      int next = it.key () + sz;

      if (opc == ip[next])
        { // 2 jumps in a row - Delete the second one.
          remove_jmp (bvp, fixup, next, sz + 1, large);
          fixup.erase (it.link()->next);
        }

      if (label_get (large, &ip[it.key ()]) == sz)
        { // Trivial jump - Delete.
          sorted_list<>::iterator tmp = it;
          ++tmp;
          fixup.erase (it.link ());
          remove_jmp (bvp, fixup, next - sz - 1, sz + 1, large);
          it = tmp;
        }
      else if (ip[it.key () + label_get (large, ip + it.key ())] == OP_RET)
        { // Jump and return - Simplify to ret.
          ip[it.key () - 1] = OP_RET;
          sorted_list<>::iterator tmp = it;
          ++tmp;
          fixup.erase (it.link ());
          remove_jmp (bvp, fixup, next - sz, sz, large);
          it = tmp;
        }
      else
        ++it;
    }
}

static void
optimize_jmps (bvector *bvp, sorted_list<>& fixup, bool large)
{
  condense_jmps (bvp, fixup, large);
  simplify_jmps (bvp, fixup, large);

  bool pass = false;

  for (sorted_list<>::iterator it (fixup); it.valid (); ++it)
    {
      int idx = it.key () + label_get (large, bvp->data + it.key ());
      if (bvp->data[idx] == OP_LOADNIL && bvp->data[idx + 1] == OP_POP)
        {
          remove_jmp (bvp, fixup, idx, 1, large);
          label_put (large, bvp->data + it.key (),
                     label_get (large, bvp->data + it.key ()) + 1);
          pass = true;
        }
    }

  if (pass)
    simplify_jmps (bvp, fixup, large);
}

bvector* bc_compiler::encode (bool release)
{
  auto& cv = this->code;
  bool large = cv.size () + (3 * cv.size () / 2) >= 0xffff;

  sorted_list<> lbl_loc, fixup_lbl;

  for (unsigned int it = 0; it < cv.size (); )
    {
      object vi = cv[it++];
      if (vi == OPX_(LABEL))
        {
          lbl_loc.add (cv[it++], this->bc_len ());
          continue;
        }

      const bcode_instr *instrp = bcode_get (as_int (vi));
      if (large && !instrp->long_p () && instrp->branch_p ())
        instrp = bcode_get (as_int (vi = make_lform (vi)));

      this->bytecode_write ((uint8_t)as_int (vi));

      if (instrp->branch_p ())
        {
          fixup_lbl.add (this->bc_len (), cv[it++]);
          this->bytecode_write ((int16_t)0);
          if (large)
            this->bytecode_write ((int16_t)0);
          continue;
        }
      else
        for (int i = 0; i < instrp->nops (); ++i)
          if (instrp->argsize () > 1)
            this->bytecode_write ((int32_t)as_int (cv[it + i]));
          else
            this->bytecode_write ((uint8_t)as_int (cv[it + i]));

      it += instrp->nops ();
    }

  bvector *bvp = this->bytecode.get ();

  // Convert labels to bytecode offsets.
  for (sorted_list<>::iterator it (fixup_lbl); it.valid (); ++it)
    label_put (large, bvp->data + it.key (),
               lbl_loc.get (it.val (), 0) - it.key ());

  // Minimize the amount of jumps needed.
  optimize_jmps (bvp, fixup_lbl, large);
  if (release)
    this->bytecode.release ();

  return (bvp);
}

object bc_compiler::encode ()
{
  bvector *bvp = this->encode (true);
  bvp->vo_full |= FLAGS_CONST;
  this->interp->alval = bvp->as_obj ();
  gc_register (this->interp, bvp, sizeof (*bvp) + this->bytecode.alloc);
  return (this->interp->alval);
}

static inline int
index_of (object item, object lst, int start = 0)
{
  for ( ; ; ++start, lst = xcdr (lst))
    if (lst == NIL)
      return (-1);
    else if (item == xcar (lst))
      return (start);
}

static inline bool
in_env (object s, object env)
{
  for (; env != NIL; env = xcdr (env))
    for (object sub = xcar (env); sub != NIL; sub = xcdr (sub))
      if (s == xcar (sub))
        return (true);

  return (false);
}

static inline int
lookup_sym (object s, object env, int& depth)
{
  for (depth = 0; env != NIL; env = xcdr (env), ++depth)
    {
      int i = index_of (s, xcar (env));
      if (i >= 0)
        return (i);
    }

  return (-1);
}

enum
{
  SPECFORM_DOTTED,
  SPECFORM_TOOMANY,
  SPECFORM_TOOFEW
};

static exception
specform_error (interpreter *interp, const char *form, int type)
{
  char buf[128], *bp = buf;
  int lenf = (int)strlen (form);

  memcpy (bp, form, lenf);
  bp[lenf++] = ':';
  bp[lenf++] = ' ';

  bp += lenf;

  if (type == SPECFORM_DOTTED)
    memcpy (bp, "got a dotted list", 18);
  else if (type == SPECFORM_TOOMANY)
    memcpy (bp, "too many parameters", 20);
  else if (type == SPECFORM_TOOFEW)
    memcpy (bp, "too few parameters", 19);

  return (interp->raise ("syntax-error", buf));
}

static const struct
{
  object code;
  const char *name;
  uint32_t namelen;
  int argcnt;
} global_builtins[] =
{
  { OPX_(IS), "is", 2, 2 },
  { OPX_(NOT), "not", 3, 1 },
  { OPX_(CONS), "cons", 4, 2 },
  { OPX_(CAR), "car", 3, 1 },
  { OPX_(CDR), "cdr", 3, 1 },
  { OPX_(CADR), "cadr", 4, 1 },
  { OPX_(APPLY), "apply", 5, -2 },
  { OPX_(SYMNAME), "symname", 7, 1 },
  { OPX_(SYMPKG), "sympkg", 6, 1 },
  { OPX_(COROVAL), "coro-val", 8, 1 },
  { OPX_(TYPEP), "char-p", 6, 1 },
  { OPX_(TYPEP), "list-p", 6, 1 },
  { OPX_(TYPEP), "str-p", 5, 1 },
  { OPX_(TYPEP), "array-p", 7, 1 },
  { OPX_(TYPEP), "table-p", 7, 1 },
  { OPX_(TYPEP), "tuple-p", 7, 1 },
  { OPX_(TYPEP), "symbol-p", 8, 1 },
  { OPX_(TYPEP), "fct-p", 5, 1 },
  { OPX_(TYPEP), "coro-p", 6, 1 },
  { OPX_(TYPEP), "pkg-p", 5, 1 },
  { OPX_(TYPEP2), "int-p", 5, 1 },
  { OPX_(TYPEP2), "float-p", 7, 1 },
  { OPX_(TYPEP2), "bvector-p", 9, 1 }
};

static const int typep_codes[] =
{
  typecode::CHAR, typecode::CONS, typecode::STR, typecode::ARRAY,
  typecode::TABLE, typecode::TUPLE, typecode::SYMBOL, typecode::FCT,
  typecode::CORO, typecode::PKG
};

static const int typep2_codes[] =
{
  typecode::INT | (typecode::BIGINT << 8),
  typecode::FLOAT | (typecode::BIGFLOAT << 8),
  typecode::BVECTOR | (typecode::STR << 8)
};

static const int typep_start = 10;
static const int typep2_start = 20;

static inline int
find_builtin (const string* np, int *nmaxp = nullptr, object expr = UNBOUND)
{
  for (int i = 0; i < (int)KP_NELEM (global_builtins); ++i)
    if (global_builtins[i].namelen == np->nbytes &&
        memcmp (global_builtins[i].name, np->data, np->nbytes) == 0)
      return (i);

  if (!nmaxp)
    return (-1);

  object head = xcar (expr);
  if (symbol_p (head) && len_s (symname (head)) == 3 &&
      memcmp (str_cdata (symname (head)), "isa", 3) == 0 &&
      xcdr (xcddr (expr)) == NIL)
    {
      object last = xcar (xcddr (expr));
      if (!symbol_p (last) ||
          !as_symbol(last)->flagged_p (symbol::literal_flag) ||
          !builtin_typespec_p (last = symval (last)))
        return (-1);

      /* We got an expression with the form (isa x TYPE-t).
       * Transform it into (TYPE-p x) */

      char buf[32];
      object name = symname (type_name (last));
      uint32_t len = len_s (name);

      memcpy (buf, str_cdata (name), len + 1);
      buf[len - 1] = 'p';

      local_varobj<string> tmp;
      tmp.local_init (buf, len_s (name));

      int ret = find_builtin (&tmp);
      if (ret >= 0)
        {
          *nmaxp = 1;
          return (ret);
        }
    }

  return (-1);
}

static object
lookup_ctv (object env, object sym)
{
  for (; env != NIL; env = xcdr (env))
    for (object sub = xcar (env); sub != NIL; sub = xcddr (sub))
      if (sym == xcar (sub))
        return (xcadr (sub));

  return (sym & ~EXTRA_BIT);
}

static inline object
lookup_alias (object env, object sym)
{
  return (lookup_ctv (env, sym | EXTRA_BIT));
}

static object
cfold (interpreter *interp, object expr, object env, object ct_env)
{
  switch (itype (expr))
    {
      case typecode::CONS:
      case typecode::SYMBOL:
       break;

      case typecode::STR:
      case typecode::ARRAY:
      case typecode::BVECTOR:
       if (deref (length (interp, expr)) == fixint (0))
         return (expr);

      case typecode::TABLE:
      case typecode::TUPLE:
        expr = UNBOUND;
      default:
        return (expr);
    }

  if (expr == NIL)
    return (expr);
  else if (symbol_p (expr))
    return (!in_env (expr, env) && lookup_alias (ct_env, expr) == expr &&
            as_symbol(expr)->flagged_p (symbol::literal_flag) ?
            symval (expr) : UNBOUND);

  object head = xcar (expr), xt;
  int idx;

  if (head == symbol::quote && cons_p (xcdr (expr)) && xcddr (expr) == NIL)
    return (xcadr (expr));
  else if (nksymbol_p (head) &&
      (idx = find_builtin (as_str (symname (head)))) >= 0 &&
      len_L (interp, xcdr (expr), xt) ==
        global_builtins[idx].argcnt && xt == NIL)
    {
      xt = global_builtins[idx].code;
      if ((xt == OPX_(CAR) || xt == OPX_(CDR)) &&
          (head = cfold (interp, xcadr (expr), env, ct_env)) != UNBOUND &&
          xcons_p (head))
        return (xt == OPX_(CAR) ? xcar (head) : xcdr (head));
      else if (xt == OPX_(IS))
        {
          object a1 = cfold (interp, xcadr (expr), env, ct_env),
                 a2 = cfold (interp, xcar (xcddr (expr)), env, ct_env);

          if (a1 != UNBOUND && a2 != UNBOUND)
            return (a1 == a2 ? symbol::t : NIL);

          object elem = xcadr (expr);
          if (symbol_p (elem) && elem == xcar (xcddr (expr)) &&
              lookup_alias (ct_env, elem) == elem && in_env (elem, env))
            return (symbol::t);
        }
    }

  return (UNBOUND);
}

// Forward declarations.
static result<object> macroexp_atom (interpreter *, object, object);
static result<object> macroexp_cons (interpreter *, object, object);

// Evaluation results.
enum
{
  EVR_NIL,
  EVR_ATOM,
  EVR_IRET,
  EVR_BRK,
  EVR_CONT,
  EVR_YIELD,
  EVR_SE = 0x80,
  EVR_NIL_SE = EVR_NIL | EVR_SE,
  EVR_ATOM_SE = EVR_ATOM | EVR_SE,
  EVR_NONE = 0xff
};

static inline bool
evr_nlexit_p (int r)
{
  return (r == EVR_IRET || r == EVR_BRK || r == EVR_CONT);
}

result<int> bc_compiler::compile_atom (object env, bool tail,
                                       object expr, bool quoted)
{
  if (expr == fixint (0))
    this->emit (OPX_(LOAD0));
  else if (expr == fixint (1))
    this->emit (OPX_(LOAD1));
  else if (fixint_p (expr))
    this->emit (OPX_(LOADI8), expr);
  else if (char_p (expr))
    this->emit (OPX_(LOADCHR8), expr);
  else if (expr == symbol::t)
    this->emit (OPX_(LOADT));
  else if (expr == NIL)
    {
      this->emit (OPX_(LOADNIL));
      return (EVR_NIL);
    }
  else
    {
      if (!quoted)
        {
          if (str_p (expr))
            {
              expr = KP_TRY (expand_str (this->interp, expr));
              if (!str_p (expr))
                {
                  KP_VTRY (this->interp->push (expr),
                           this->compile_in (env, tail, expr));
                  this->interp->popn ();
                  return (EVR_NONE);
                }
            }

          bool rv = KP_TRY (this->compile_seq (env, tail, expr));
          if (rv)
            return (EVR_ATOM_SE);
        }

      this->emit (OPX_(LOADV), expr);
    }

  return (EVR_ATOM);
}

result<int> bc_compiler::compile_sym (object env, bool tail,
                                      object s, const operation_set& ops)
{
  KP_VTRY (macroexp_atom (this->interp, this->ct_env, s));
  if (this->interp->retval != s)
    { // Evaluate the expanded alias.
      valref tmp (this->interp, this->interp->retval);
      return (this->compile_in (env, false, *tmp));
    }

  int depth, loc = lookup_sym (s, env, depth);
  if (loc < 0)
    {
      if (as_symbol(s)->flagged_p (symbol::literal_flag) &&
          !ops.write && symval (s) != UNBOUND)
        return (this->compile_atom (env, tail, symval (s), true));
      else
        { // Dynamic access.
          if (as_symbol(s)->flagged_p (symbol::special_flag))
            this->emit (ops.dynamic, s);
          else
            {
              int s_idx = builtin_idx (interp, str_cdata (symname (s)));
              if (s_idx < 0)
                {
                  if (as_symbol(s)->flagged_p (FLAGS_CONST) && ops.write &&
                      (this->rflags & flg_warnings))
                    BC_WARN (*this, "setting constant %Q will always fail", s);

                  this->emit (ops.global, s);
                }
              else
                this->emit (ops.write ?
                            OPX_(SETFGS) : OPX_(LOADFGS), fixint (s_idx));
            }
        }
    }
  else if (depth >= this->frames.size)
    { // Outside this function's scope.
      auto bp = this->bprev, self = this;
      int nprev = 0;

      for (depth -= this->frames.size ; ; ++nprev)
        { // XXX: Check this.
          if (depth < bp->frames.size)
            break;

          depth -= bp->frames.size;
          self = bp, bp = bp->bprev;
          self->capt_idx.root.val = 1;
        }

      auto& f = bp->frames[bp->frames.size - depth - 1];
      loc += f.acc;
      if (bp->captures.set (loc))
        {
          bp->code.insert (bp->code.begin () + *f.ipp + 0, OPX_(BOX));
          bp->code.insert (bp->code.begin () + *f.ipp + 1, fixint (loc));
          *f.ipp += 2;
        }

      auto np = self->capt_idx.add (loc);
      if (np->val < 0)
        np->val = self->capt_idx.len () - 1;

      this->capt_idx.root.val = 1;
      this->emit (ops.closure, fixint (nprev), fixint (np->val));
    }
  else
    { // Local (possibly boxed) variable.
      auto& f = this->frames[this->frames.size - depth - 1];
      bool boxed_p = this->captures.get (f.acc + loc);
      this->emit (boxed_p ? ops.boxed : ops.local, fixint (f.acc + loc));
    }

  return (EVR_NONE);
}

result<int> bc_compiler::compile_cond (object env, bool tail,
                                       object expr, bool popa)
{
  size_t pos = this->code.size ();
  int r = KP_TRY (this->compile_in (env, tail, expr));
  if (r == EVR_NIL || r == EVR_ATOM)
    this->erase (this->code.begin () + pos, this->code.end ());
  else if (popa && (r == EVR_NIL_SE || r == EVR_ATOM_SE))
    {
      object lasti = this->code.back ();
      if (lasti == OPX_(LOADT) || lasti == OPX_(LOADNIL))
        this->code.pop_back ();
      else
        this->code.push_back (OPX_(POP));
    }

  return (r);
}

result<int> bc_compiler::compile_if (object env, bool tail, object x)
{
  if (!xcons_p (x) || !xcons_p (xcdr (x)))
    return (specform_error (this->interp, "if", SPECFORM_DOTTED));
  else if (xcdr (x) == NIL)
    return (specform_error (this->interp, "if", SPECFORM_TOOFEW));

  object tst = xcar (x);
  object then = xcadr (x);
  object els = xcddr (x);

  insertp_handler ih (*this);
  int r = KP_TRY (this->compile_cond (env, false, tst));
  r &= ~EVR_SE;

  if (kp_unlikely (evr_nlexit_p (r)))
    return (r);
  else if (kp_unlikely (r == EVR_ATOM))
    return (this->compile_in (env, tail, then));
  else if (kp_unlikely (r == EVR_NIL))
    return (xcdr (els) == NIL ? this->compile_in (env, tail, xcar (els)) :
                                this->compile_if (env, tail, els));

  int el = this->next_label (), endl = this->next_label ();
  this->emit (OPX_(BRN), fixint (el));
  r = KP_TRY (this->compile_in (env, tail, then));

  if (evr_nlexit_p (r))
    ;
  else if (tail)
    this->emit (OPX_(RET));
  else
    this->emit (OPX_(JMP), fixint (endl));

  this->mark_label (el);

  if (xcdr (els) != NIL)
    KP_VTRY (this->compile_if (env, tail, els));
  else
    KP_VTRY (this->compile_in (env, tail, xcar (els)));

  this->mark_label (endl);
  return (EVR_NONE);
}

static result<int>
compile_while_helper (bc_compiler& bc, object env, object cond,
                      object body, object lbl, bool& pad)
{
  int r = KP_TRY_IP (bc.interp, bc.compile_cond (env, false, cond));
  int rm = r & ~EVR_SE;

  if (kp_unlikely (rm == EVR_NIL))
    {
      bc.emit (OPX_(LOADNIL));
      return (r);
    }
  else if (evr_nlexit_p (r))
    return (r);
  else if (r == EVR_ATOM)
    {
      r = KP_TRY_IP (bc.interp, bc.compile_in (env, false, body));
      bc.emit (OPX_(POP));
    }
  else
    {
      bc.emit (OPX_(BRN), lbl);
      bc.emit (OPX_(POP));
      r = KP_TRY_IP (bc.interp, bc.compile_in (env, false, body));
      pad = true;
    }

  return (r);
}

result<int> bc_compiler::compile_while (object env, object cond, object body)
{
  whl_block blk;
  whl_handler whandler (*this, &blk);
  size_t pos = this->code.size (), ncapts = this->captures.nelem;
  bool pad = false;

  insertp_handler ih (*this);
  this->mark_label (blk.top_lbl);

  int r = KP_TRY (compile_while_helper (*this, env, cond, body,
                                        fixint (blk.end_lbl), pad));

  if (this->cur_f().ipp == &ih.ipoint && ncapts != this->captures.nelem)
    { /* This 'while' loop references a boxed variable that wasn't boxed
       * before. Undo the last expression and retry with them already boxed. */
      pos = ih.ipoint;
      this->erase (this->code.begin () + pos + 2, this->code.end ());
      KP_VTRY (compile_while_helper (*this, env, cond, body,
                                     fixint (blk.end_lbl), pad));
    }

  if (pad)
    this->code.insert (this->code.begin () + pos, OPX_(LOADT));

  if (r != EVR_NIL && !evr_nlexit_p (r))
    this->emit (OPX_(IRTJMP), fixint (blk.top_lbl));

  this->mark_label (blk.end_lbl);
  return (EVR_NONE);
}

static result<int>
compile_sc_helper (bc_compiler& bc, object env, bool tail,
                   object forms, object dfl, object branch)
{
  if (!xcons_p (forms))
    return (specform_error (bc.interp, dfl == symbol::t ?
                            "and" : "or", SPECFORM_DOTTED));
  else if (forms == NIL)
    return (bc.compile_in (env, tail, dfl));
  else if (xcdr (forms) == NIL)
    return (bc.compile_in (env, tail, xcar (forms)));

  object cf = xcar (forms);
  int r = KP_TRY_IP (bc.interp, bc.compile_cond (env, false, cf, false));
  int rm = r & ~EVR_SE;

  if (kp_unlikely (r == EVR_IRET))
    return (r);
  else if (kp_unlikely (rm == EVR_NIL || rm == EVR_ATOM))
    { // Constant form.
      if ((rm == EVR_NIL && dfl != symbol::t) || (rm == EVR_ATOM && dfl != NIL))
        // Skip constant form.
        return (bc.compile_short_circuit (env, tail, xcdr (forms),
                                          dfl, branch));
      else if ((r & EVR_SE) == 0)
        KP_VTRY (bc.compile_in (env, true, cf));

      // nil argument in 'and' form, or non-nil argument in 'or' form.
      return (r);
    }

  int end = bc.next_label ();
  bc.emit (branch, fixint (end));
  KP_VTRY (bc.compile_short_circuit (env, tail,
                                     xcdr (forms), dfl, branch));
  bc.mark_label (end);
  return (EVR_NONE);
}

result<int> bc_compiler::compile_short_circuit (object env, bool tail,
                                                object forms, object dfl,
                                                object branch)
{
  insertp_handler ih (*this);
  return (compile_sc_helper (*this, env, tail, forms, dfl, branch));
}

result<int> bc_compiler::compile_arglist (object env, object expr,
                                          int off, int nmax)
{
  int ret = 0;
  this->cur_f().stkdisp += off;

  for (; expr != NIL && ret < nmax;
      expr = xcdr (expr), ++ret, ++this->cur_f().stkdisp)
    if (xcons_p (expr))
      KP_VTRY (this->compile_in (env, false, xcar (expr)));
    else
      return (this->interp->raise ("arg-error",
                                   "argument list must not be dotted"));

  this->cur_f().stkdisp -= ret + off;
  return (ret);
}

void bc_compiler::test_nargs_fct (object obj, object env, int nargs)
{
  if (!(this->rflags & flg_warnings) || in_env (obj, env))
    return;

  valref f (this->interp, obj);
  if (!symbol_p (*f) || !fct_p (*f = symval (*f)))
    return;

  function_base *fbp = (function_base *)unmask (*f);
  auto rv = deref (fbp->test_nargs (this->interp, nargs, false));
  if (rv)
    return;

  char buf[128];
  this->interp->nargs_msg (buf, sizeof (buf) - 1,
                           fbp->min_argc, fbp->max_argc, nargs);

  BC_WARN (*this, buf, fbp->name);
}

result<int> bc_compiler::compile_app (object env, bool tail, object expr)
{
  object h = xcar (expr);
  int nmax = INT_MAX;
  int bidx = !nksymbol_p (h) ? -1 :
             find_builtin (as_str (symname (h)), &nmax, expr);

  if (bidx < 0)
    {
      KP_VTRY (macroexp_cons (this->interp, this->ct_env, expr));
      if (this->interp->retval != expr)
        { // Evaluate the macro-expansion.
          valref tmp (this->interp, this->interp->retval);
          return (this->compile_in (env, tail, *tmp));
        }

      // Evaluate the calling function's definition.
      KP_TRY (this->compile_in (env, false, h));
    }
  else
    {
      auto e_len = KP_TRY (len_L (this->interp, xcdr (expr)));
      int len = min (e_len, nmax);
      int cnt = global_builtins[bidx].argcnt;

      if ((cnt >= 0 && len != cnt) || (cnt < 0 && len < -cnt))
        {
          this->emit (OPX_(LOADG), xcar (expr));
          bidx = -1;
        }
    }

  int nargs = KP_TRY (this->compile_arglist (env, xcdr (expr),
                                             bidx < 0, nmax));
  if (bidx < 0)
    {
      this->emit (tail ? OPX_(TCALL) : OPX_(CALL), fixint (nargs));
      this->test_nargs_fct (h, env, nargs);
    }
  else
    {
      object instr = global_builtins[bidx].code;
      if (instr == OPX_(APPLY))
        this->emit (tail ? OPX_(TAPPLY) : OPX_(APPLY), fixint (nargs));
      else if (instr == OPX_(TYPEP))
        this->emit (instr, fixint (typep_codes[bidx - typep_start]));
      else if (instr == OPX_(TYPEP2))
        {
          int tx = typep2_codes[bidx - typep2_start];
          this->emit (instr, fixint (tx & 0xff), fixint (tx >> 8));
        }
      else
        this->emit (instr);
    }

  return (EVR_NONE);
}

result<int> bc_compiler::compile_do (object env, bool tail, object forms)
{
  if (!cons_p (forms))
    {
      this->emit (OPX_(LOADT));
      return (EVR_ATOM);
    }
  else if (!cons_p (xcdr (forms)))
    return (this->compile_in (env, tail, xcar (forms)));

  int r = KP_TRY (this->compile_cond (env, false, xcar (forms)));
  r &= ~EVR_SE;

  if (r == EVR_IRET || r == EVR_BRK || r == EVR_CONT)
    // Ignore every expression after this form.
    return (r);
  else if (r != EVR_NIL && r != EVR_ATOM)
    this->emit (OPX_(POP));

  r = KP_TRY (this->compile_do (env, tail, xcdr (forms)));
  return (r == EVR_ATOM || r == EVR_NIL ? (r | EVR_SE) : r);
}

static inline int
get_specform (const string* sp)
{
  return (symbol::specform_byname (sp->data, sp->nbytes));
}

/* For sequences that may contain symbols (i.e: arrays, tables and tuples),
 * modify the expression so that instead of a literal, it becomes a call
 * to its respective constructor function, therefore evaluating the
 * symbols into values. */
result<bool> bc_compiler::compile_seq (object env, bool tail, object expr)
{
  tmp_allocator ta { this->interp };
  cons *tmp;
  char name[16] = "";
  uint32_t namelen, i = 0;

  if (array_p (expr))
    {
      const array *ap = as_array (expr);
      if (ap->len == 0)
        return (false);

      tmp = (cons *)ta.alloc (ap->len * sizeof (*tmp));

      for (; i < ap->len; ++i)
        tmp[i].car = ap->data[i];

      memcpy (name, "array", namelen = 5);
    }
  else if (table_p (expr))
    {
      uint32_t len = len_u (expr);
      tmp = (cons *)ta.alloc ((len + 1) * 2 * sizeof (*tmp));

      // Push the test and hash functions.
      tmp[i++].car = NIL;
      tmp[i++].car = NIL;

      // Push the key/value pairs.
      for (table::iterator it (this->interp, expr); it.valid (); ++it)
        {
          tmp[i++].car = it.key ();
          tmp[i++].car = it.val ();
        }

      memcpy (name, "table", namelen = 5);
    }
  else if (tuple_p (expr))
    {
      uint32_t len = len_o (expr);
      tmp = (cons *)ta.alloc ((len + 1) * sizeof (*tmp));

      // Push the test function.
      tmp[i++].car = NIL;

      // Push the keys.
      for (tuple::iterator it (this->interp, expr); it.valid (); ++it)
        tmp[i++].car = *it;

      memcpy (name, "tuple", namelen = 5);
    }
  else if (bvector_p (expr))
    { /* Byte vectors don't really have a constructor, but we still need
       * to copy them so as to make them unique across calls. */
      tmp = (cons *)ta.alloc (5 * sizeof (*tmp));
      tmp[i++].car = tmp[3].as_obj ();
      tmp[3].car = symbol::quote;
      tmp[3].cdr = tmp[4].as_obj ();
      tmp[4].car = expr;
      tmp[4].cdr = NIL;

      memcpy (name, "copy", namelen = 4);
    }
  else
    return (false);

  // Link the contiguous conses.
  for (uint32_t j = 0; j < i - 1; ++j)
    tmp[j].cdr = tmp[j + 1].as_obj ();

  tmp[i - 1].cdr = NIL;

  int s_idx = builtin_idx (this->interp, name);
  if (s_idx >= 0)
    this->emit (OPX_(LOADFGS), fixint (s_idx));
  else
    {
      object sym = find_sym (this->interp, name, namelen);
      if (!symbol_p (sym))
        return (false);

      this->emit (OPX_(LOADG), sym);
    }

  KP_VTRY (this->compile_arglist (env, tmp->as_obj ()));
  this->emit (tail ? OPX_(TCALL) : OPX_(CALL) , fixint (i));

  return (true);
}

result<void> bc_compiler::compile_try (object env, bool, object expr)
{
  insertp_handler ih (*this);
  int clbl = this->next_label (), end = this->next_label ();
  this->emit (OPX_(TRYBEGIN), fixint (clbl));
  ++this->exc_depth;
  this->cur_f().stkdisp += 2;

  int rv = KP_TRY (this->compile_in (env, false, xcadr (expr)));
  if (!evr_nlexit_p (rv))
    {
      this->emit (OPX_(TRYEND));
      this->emit (OPX_(JMP), fixint (end));
    }

  this->cur_f().stkdisp -= 2;
  --this->exc_depth;
  this->mark_label (clbl);

  auto prev = this->rflags & flg_incatch;
  this->rflags |= flg_incatch;

  rv = KP_TRY (this->compile_in (env, false, xcar (xcddr (expr))));
  if (!evr_nlexit_p (rv))
    this->emit (OPX_(CLREXC));

  this->rflags = (this->rflags & ~flg_incatch) | prev;
  this->mark_label (end);

  return (0);
}

static const bc_compiler::operation_set LOAD_OPS =
{
  OPX_(LOADA), OPX_(LOADC), OPX_(LOADG), OPX_(LOADB), OPX_(LOADX), false
};

static const bc_compiler::operation_set SET_OPS =
{
  OPX_(SETA), OPX_(SETC), OPX_(SETG), OPX_(SETB), OPX_(SETG), true
};

static exception
outside_error (interpreter *interp, const char *form, const char *where)
{
  char buf[64];
  sprintf (buf, "'%s' outside %s", form, where);
  return (interp->raise ("syntax-error", buf));
}

result<int> bc_compiler::compile_in (object env, bool tail, object expr)
{
  if (symbol_p (expr))
    return (this->compile_sym (env, tail, expr, LOAD_OPS));
  else if (atom_p (expr))
    return (this->compile_atom (env, tail, expr));

  object e1 = cfold (this->interp, expr, env, this->ct_env);
  if (e1 != UNBOUND)
    // A constant expression is always implicitly quoted.
    return (this->compile_atom (env, tail, e1, true));

  // Complex expression.
  e1 = xcar (expr);
  if (!nksymbol_p (e1))
    return (this->compile_app (env, tail, expr));

  switch (get_specform (as_str (symname (e1))))
    {
      case SF_QUOTE:
        if (!xcons_p (xcdr (expr)))
          return (specform_error (this->interp, "quote", SPECFORM_DOTTED));
        else if (xcdr (expr) == NIL)
          return (specform_error (this->interp, "quote", SPECFORM_TOOFEW));
        else if (xcddr (expr) != NIL)
          return (specform_error (this->interp, "quote", SPECFORM_TOOMANY));

        return (this->compile_atom (env, tail, xcadr (expr), true));

      case SF_IF:
        return (this->compile_if (env, tail, xcdr (expr)));
      case SF_DO:
        return (this->compile_do (env, tail, xcdr (expr)));

      case SF_FCT:
        {
          if (!xcons_p (xcdr (expr)))
            return (specform_error (this->interp, "fct", SPECFORM_DOTTED));
          else if (xcdr (expr) == NIL)
            return (specform_error (this->interp, "fct", SPECFORM_TOOFEW));
          
          insertp_handler ih (*this);
          bc_compiler bc (this->interp, bc_compiler::flg_warnings);
          bc.bprev = this;
          object fn = KP_TRY (bc.compile_fct (env, xcdr (expr)));

          KP_VTRY (this->interp->push (fn));
          this->emit (OPX_(LOADV), fn);

          if (bc.capt_idx.root.val)
            {
              object vec = KP_TRY (alloc_array (this->interp,
                                                bc.capt_idx.len ()));
              for (sorted_list<>::iterator it (bc.capt_idx); it.valid (); ++it)
                xaref(vec, it.val ()) = fixint (it.key ());

              as_fct(fn)->env = vec;
              this->emit (OPX_(CLOSURE));
            }

          return (EVR_ATOM_SE);
        }

      case SF_AND:
        return (this->compile_and (env, tail, xcdr (expr)));
      case SF_OR:
        return (this->compile_or (env, tail, xcdr (expr)));

      case SF_WHILE:
        {
          if (xcdr (expr) == NIL)
            return (specform_error (this->interp, "while", SPECFORM_TOOFEW));
          else if (!xcons_p (xcdr (expr)))
            return (specform_error (this->interp, "while", SPECFORM_DOTTED));

          cons *ep = this->expr_do ();
          ep->cdr = xcddr (expr);
          return (this->compile_while (env, xcadr (expr), ep->as_obj ()));
        }

      case SF_BREAK:
        if (!this->whl)
          return (outside_error (this->interp, "break", "while loop"));
        else if (!xcons_p (xcdr (expr)))
          return (specform_error (this->interp, "break", SPECFORM_DOTTED));
        else if (xcddr (expr) != NIL)
          return (specform_error (this->interp, "break", SPECFORM_TOOMANY));

        KP_VTRY (this->compile_in (env, false, xcadr (expr)));
        this->unwind_state (this->whl);
        this->emit (OPX_(JMP), fixint (this->whl->end_lbl));
        return (EVR_BRK);

      case SF_CONTINUE:
        if (!this->whl)
          return (outside_error (this->interp, "continue", "while loop"));
        else if (xcdr (expr) != NIL)
          return (this->interp->raise ("syntax-error",
                                       "invalid argument in "
                                       "'continue' expression"));

        this->unwind_state (this->whl);
        this->emit (OPX_(LOADNIL));
        this->emit (OPX_(IRTJMP), fixint (this->whl->top_lbl));
        return (EVR_CONT);

      case SF_RETURN:
        if (this->rflags & flg_toplevel)
          return (outside_error (this->interp, "return", "function"));
        else if (xcdr (expr) != NIL && !xcons_p (xcdr (expr)))
          return (specform_error (this->interp, "return", SPECFORM_DOTTED));
        else if (xcddr (expr) != NIL)
          return (specform_error (this->interp, "return", SPECFORM_TOOMANY));

        KP_VTRY (this->compile_in (env, true, xcadr (expr)));
        this->restore_exc (this->exc_depth);
        if (this->n_dbinds)
          this->emit (OPX_(UNBIND), fixint (this->n_dbinds));
        this->emit (OPX_(RET));
        return (EVR_IRET);

      case SF_YIELD:
        // (yield $x) is equivalent to (return (%make-cont $x))
        if (this->rflags & flg_toplevel)
          return (outside_error (this->interp, "yield", "function"));
        else if (xcdr (expr) != NIL && !xcons_p (xcdr (expr)))
          return (specform_error (this->interp, "yield", SPECFORM_DOTTED));
        else if (xcddr (expr) != NIL)
          return (specform_error (this->interp, "yield", SPECFORM_TOOMANY));

        KP_VTRY (this->compile_in (env, false, xcadr (expr)));
        this->emit (OPX_(MKCONT), fixint (1 + this->exc_depth +
          (this->n_dbinds > 0xff ? 5 : (this->n_dbinds > 0 ? 2 : 0))));
        this->restore_exc (this->exc_depth);
        if (this->n_dbinds)
          this->emit (OPX_(UNBIND), fixint (this->n_dbinds));
        this->emit (OPX_(RET));
        return (EVR_YIELD);

      case SF_SETQ:
        if (!xcons_p (xcdr (expr)) || !xcons_p (xcddr (expr)))
          return (specform_error (this->interp, "setq", SPECFORM_DOTTED));
        else if (xcddr (expr) == NIL)
          return (specform_error (this->interp, "setq", SPECFORM_TOOFEW));
        else if (xcdr (xcddr (expr)) != NIL)
          return (specform_error (this->interp, "setq", SPECFORM_TOOMANY));
        else if (!symbol_p (xcadr (expr)))
          return (this->interp->raise ("syntax-error",
                                       "setq requires a symbol"));

        KP_VTRY (this->compile_in (env, false, xcar (xcddr (expr))),
                 this->compile_sym (env, tail, xcadr (expr), SET_OPS));
        break;

      case SF_LET:
        return (this->compile_let (env, tail, xcdr (expr)));

      case SF_CALLCC:
        {
          if (this->rflags & flg_toplevel)
            return (outside_error (this->interp, "call/cc", "function"));

          bc_compiler bc (this->interp, bc_compiler::flg_warnings);
          bc.bprev = this;
          cons cc_env;

          cc_env.car = xcadr (expr);
          cc_env.cdr = env;
          insertp_handler ih (*this);
          object cls = KP_TRY (bc.compile_fct_body (cc_env.as_obj (),
                                                    xcddr (expr)));

          KP_VTRY (this->interp->push (cls));
          this->emit (OPX_(LOADV), cls);
          this->emit (OPX_(CLOSURE));
          this->emit (OPX_(LOADNIL));
          this->emit (OPX_(MKCONT), fixint (2));
          this->emit (tail ? OPX_(TCALL) : OPX_(CALL), fixint (1));
          break;
        }

      case SF_RECUR:
        {
          if (this->rflags & flg_toplevel)
            return (outside_error (this->interp, "recur", "function"));

          this->emit (OPX_(LDCALLER));
          int n = KP_TRY (this->compile_arglist (env, xcdr (expr)));
          this->emit (tail ? OPX_(TRECUR) : OPX_(RECUR), fixint (n));

          if (n < this->min_argc || (uint32_t)n > (uint32_t)this->max_argc &&
              (this->rflags & flg_warnings))
            {
              char buf[128];
              this->interp->nargs_msg (buf, sizeof (buf) - 1, this->min_argc,
                                       this->max_argc, n);

              local_varobj<string> sf;
              sf.local_init ("#:recur", 7);

              BC_WARN (*this, buf, sf.as_obj ());
            }

          break;
        }

      case SF_TRY:
        if (!xcons_p (xcdr (expr)) || !xcons_p (xcddr (expr)))
          return (specform_error (this->interp, "try", SPECFORM_DOTTED));
        else if (xcddr (expr) == NIL)
          return (specform_error (this->interp, "try", SPECFORM_TOOFEW));
        else if (xcdr (xcddr (expr)) != NIL)
          return (specform_error (this->interp, "try", SPECFORM_TOOMANY));

        KP_VTRY (this->compile_try (env, tail, expr));
        break;

      case SF_RAISE:
        {
          int n = KP_TRY (this->compile_arglist (env, xcdr (expr), 0));
          if (n > 2)
            return (specform_error (this->interp, "raise", SPECFORM_TOOMANY));

          this->emit (OPX_(RAISE), fixint (n));
          break;
        }

      default:
        KP_VTRY (this->compile_app (env, tail, expr));
    }

  return (EVR_NONE);
}

struct arglist
{
  cons *ptr = nullptr;
  uint32_t n = 0;

  void add_sym (cons *basep, object sym)
    {
      if (!this->ptr)
        this->ptr = basep;

      cons *outp = this->ptr + this->n++;
      outp->cdr = outp[1].as_obj ();
      outp->car = sym;
    }

  void fixup_env ()
    { /* For keyword and optional arguments, we need to strip the
       * default definition in the environment lists. */
      for (uint32_t i = 0; i < this->n; ++i)
        this->ptr[i].car = xcar (this->ptr[i].car);
    }
};

struct proc_args
{
  cons *buf;
  arglist req;
  arglist opt;
  arglist kw;

  proc_args (cons *space) : buf (space) {}

  result<int> parse (interpreter *interp, object args)
    {
      bool kwargs = false, optargs = false;
      for (object orig = args ; ; args = xcdr (args))
        {
          if (args == NIL || symbol_p (args))
            break;
          else if (!cons_p (args))
            {
            invalid_arglist:
              if (orig == args)
                return (interp->raise ("arg-error",
                                       KP_SPRINTF (interp,
                                                   "invalid argument list: %Q",
                                                   orig)));
              else
                return (interp->raise ("arg-error",
                                       KP_SPRINTF (interp, "invalid required "
                                                           "argument: %Q",
                                                           args)));
            }

          object tmp = xcar (args);
          if (nksymbol_p (tmp))
            {
              if (optargs || kwargs)
                return (interp->raise ("arg-error",
                                       KP_SPRINTF (interp, "optional arguments "
                                                           "must come after "
                                                           "required ones")));

              req.add_sym (this->buf, tmp);
            }
          else if (!cons_p (tmp))
            goto invalid_arglist;
          else if (!cons_p (xcdr (tmp)) ||
              xcddr (tmp) != NIL || !symbol_p (xcar (tmp)))
            return (interp->raise ("arg-error",
                                   KP_SPRINTF (interp, "invalid optional "
                                                       "argument: %Q",
                                                       tmp)));
          else if (keyword_p (xcar (tmp)))
            {
              kwargs = true;
              this->kw.add_sym (this->buf + this->req.n + this->opt.n, tmp);
            }
          else
            {
              if (kwargs)
                return (interp->raise ("arg-error",
                                       KP_SPRINTF (interp, "keyword arguments "
                                                           "must come last")));

              optargs = true;
              this->opt.add_sym (this->buf + this->req.n, tmp);
            }
        }

      return (0);
    }
};

result<void> bc_compiler::emit_optargs_init (object env, object opta,
                                            object vars, int idx)
{
  for (; opta != NIL; ++idx, opta = xcdr (opta))
    {
      int nxt = this->next_label ();
      this->emit (OPX_(BRBOUND), fixint (idx));
      this->emit (OPX_(BRT), fixint (nxt));

      cons *p = as_cons (vars);
      object prev = p[idx].cdr;
      p[idx].cdr = NIL;

      cons aux;
      aux.car = p->as_obj ();
      aux.cdr = env;

      KP_VTRY (this->compile_in (aux.as_obj (), false, xcadr (xcar (opta))));
      this->emit (OPX_(SETA), fixint (idx));
      this->emit (OPX_(POP));
      this->mark_label (nxt);
      p[idx].cdr = prev;
    }

  return (0);
}

static result<object>
make_kwtab (interpreter *interp, arglist& args, uint32_t off = 0)
{
  uint32_t n = upsize (args.n + 1);
  object tab = KP_TRY (alloc_array (interp, n * 2, fixint (0)));

  for (uint32_t i = 0; i < args.n; ++i)
    {
      object obj = xcar (args.ptr[i].car);
      for (uint32_t idx = hash_S (interp, obj) & (n - 1) ; ;
          idx = (idx + 1) & (n - 1))
        if (xaref (tab, idx * 2) == fixint (0))
          {
            xaref(tab, idx * 2 + 0) = obj;
            xaref(tab, idx * 2 + 1) = fixint (i + off);
            break;
          }
    }

  KP_VTRY (interp->push (interp->alval));
  return (interp->stktop ());
}

result<object> bc_compiler::compile_fct (object env, object expr)
{
  object atail = NIL;
  object vars, args = xcar (expr);
  cons last;
  int nargs = 0, nreq = 0, nkw = 0;
  bool has_opt = false;
  tmp_allocator ta { this->interp };

  if (kp_likely (cons_p (args)))
    {
      nargs = len_L (this->interp, args, atail);
      cons *tmp = (cons *)ta.alloc ((nargs + 1) * sizeof (*tmp));

      proc_args pa (tmp);
      KP_VTRY (pa.parse (this->interp, args));

      nreq = pa.req.n;
      tmp[nargs - 1].cdr = NIL;

      if ((has_opt = pa.opt.n != 0 || pa.kw.n != 0))
        {
          if (pa.kw.n == 0)
            this->emit (OPX_(OPTARGS), fixint (pa.req.n),
                        fixint (atail == NIL ? nargs : -nargs));
          else
            {
              object kwtab = KP_TRY (make_kwtab (this->interp,
                                                 pa.kw, pa.opt.n));
              this->index (kwtab);
              this->emit (OPX_(KWARGS), fixint (nreq), fixint (pa.kw.n),
                          fixint (atail == NIL ? nargs : -nargs));
              nkw = pa.kw.n;
            }

          cons *first_opt = pa.opt.ptr ? pa.opt.ptr : pa.kw.ptr;
          if (pa.req.n == 0)
            pa.req.ptr = first_opt;

          for (uint32_t i = 0; i < pa.kw.n; ++i)
            { /* Convert all the keywords in the list to regular
               * symbols. Note that the keywords have been saved
               * in the table produced by 'make_kwtab'. */
              object& dst = xcar (pa.kw.ptr[i].car);
              const string *np = as_str (symname (dst));
              object sym = KP_TRY (intern (this->interp,
                                           (char *)np->data, np->nbytes));
              KP_VTRY (this->interp->push (sym));
              dst = this->interp->stktop ();
            }

          tmp[nargs - 1].cdr = NIL;
          KP_VTRY (this->emit_optargs_init (env, first_opt->as_obj (),
                                            pa.req.ptr->as_obj (), nreq));

          pa.opt.fixup_env ();
          pa.kw.fixup_env ();
        }

      if (atail != NIL)
        { // Append the varargs to the argument list.
          last.car = atail;
          last.cdr = NIL;
          tmp[nargs - 1].cdr = last.as_obj ();
        }

      this->cur_f().nargs += nargs + (atail != NIL);
      vars = tmp->as_obj ();
    }
  else
    {
      last.car = atail = args;
      last.cdr = NIL;
      vars = last.as_obj ();
      this->cur_f().nargs = atail != NIL;
    }

  if (atail == NIL)
    this->max_argc = nargs + nkw;
  else
    {
      this->emit (OPX_(VARGC), fixint (nargs));
      this->max_argc = -1;
    }

  this->min_argc = nreq;

  cons tmp;
  tmp.car = vars;
  tmp.cdr = env;

  return (this->compile_fct_body (tmp.as_obj (), xcdr (expr),
                                  (nkw ? function::kwargs_flag : 0)));
}

result<object> bc_compiler::compile_fct_body (object env,
                                              object expr, uint32_t flags)
{
  int r;

  if (xcdr (expr) == NIL)
    { // Single-expression function.
      r = KP_TRY (this->compile_in (env, true, xcar (expr)));
    }
  else
    { // Multi-expression body. Transform it into a '(do (...)).
      cons body;
      body.car = xcar (expr);
      body.cdr = xcdr (expr);
      r = KP_TRY (this->compile_do (env, true, body.as_obj ()));
    }

  if (r == EVR_YIELD)
    {
      this->emit (OPX_(LOADNIL));
      this->emit (OPX_(RET));
    }
  else if (r != EVR_IRET)
    this->emit (OPX_(RET));

  KP_VTRY (alloc_fct (this->interp, flags));
  function *retp = as_fct (this->interp->alval);
  KP_VTRY (this->interp->push (this->interp->alval));
  retp->bcode = this->encode ();
  retp->vals = KP_TRY (this->idxvec ());
  retp->max_sp = retp->max_stack ();
  retp->min_argc = this->min_argc;
  retp->max_argc = this->max_argc;

  return (this->interp->pop ());
}

static int
ctv_letdef (object ev)
{
  if (!cons_p (ev) || !keyword_p (xcar (ev)))
    return (-1);

  const string *np = as_str (symname (xcar (ev)));
  if (np->nbytes == 5)
    {
      if (memcmp ("macro", np->data, 5) == 0)
        return (0);
      else if (memcmp ("alias", np->data, 5) == 0)
        return (1);
    }

  return (-1);
}

static result<int>
eval_ctv (bc_compiler& self, object bindings, cons *ctvs, int nctv)
{
  object ev = xcadr (bindings);
  int r = ctv_letdef (ev);

  if (r < 0)
    return (r);
  else if (r == 1)
    KP_VTRY (eval (self.interp, xcadr (ev)));
  else if (r == 0)
    {
      bc_compiler tmp (self.interp, self.rflags & ~bc_compiler::flg_toplevel);
      object prev = NIL;

      tmp.ct_env = self.ct_env;
      if (nctv > 0)
        swap (prev, ctvs[nctv - 1].cdr);

      KP_VTRY (tmp.compile_fct (NIL, xcdr (ev)));
      if (nctv > 0)
        ctvs[nctv - 1].cdr = prev;
    }

  KP_VTRY (self.interp->push (self.interp->retval));
  ctvs[nctv].car = xcar (bindings) | (r ? EXTRA_BIT : 0);
  ctvs[nctv].cdr = ctvs[nctv + 1].as_obj ();
  ctvs[nctv + 1].car = self.interp->retval;
  ctvs[nctv + 1].cdr = NIL;
  return (r);
}

static inline int
count_let_nlex (object bindings)
{
  int nlex = 0;
  for (; bindings != NIL; bindings = xcddr (bindings))
    nlex += ctv_letdef (xcadr (bindings)) < 0;

  return (nlex);
}

static inline bool
special_symbol_p (object obj)
{
  return (as_symbol(obj)->flagged_p (symbol::special_flag));
}

static result<int>
array_nbindings (interpreter *interp, object obj)
{
  const array *ap = as_array (obj);
  int ret = 0;

  if (ap->len == 0)
    return (interp->raise ("arg-error",
                           "let: array bindings must not be empty"));

  for (uint32_t i = 0; i < ap->len; ++i)
    {
      if (symbol_p (ap->data[i]))
        ++ret;
      else if (array_p (ap->data[i]))
        { ret += KP_TRY (array_nbindings (interp, ap->data[i])); }
      else
        return (interp->raise ("arg-error",
                               KP_SPRINTF (interp, "let: invalid binding: %Q",
                                           ap->data[i])));
    }

  return (ret);
}

static inline result<int>
count_bindings (interpreter *interp, object obj)
{
  if (!array_p (obj))
    return (1);
  return (array_nbindings (interp, obj));
}

#define ADD_BIND(lst, obj, var)   \
  do   \
    {   \
      lst[var].car = obj;   \
      lst[var].cdr = NIL;   \
      if (var > 0)   \
        lst[var - 1].cdr = syms[var].as_obj ();   \
      ++var;   \
    }   \
  while (0)

static result<int>
flatten_array_args (bc_compiler& bc, cons *syms, object bindings,
                    bool& curr_dynamic, int& nvframes)
{
  auto interp = bc.interp;
  const array *ap = as_array (bindings);
  int ret = 0;

  for (uint32_t i = 0; i < ap->len; ++i)
    {
      if (array_p (ap->data[i]))
        {
          int rx = KP_TRY (flatten_array_args (bc, syms + ret, ap->data[i],
                                               curr_dynamic, nvframes));
          ret += rx, syms += rx;
        }
      else
        {
          object tmp = ap->data[i];

          if (special_symbol_p (tmp))
            {
              if (!curr_dynamic)
                {
                  bc.emit (OPX_(VFRAME));
                  bc.cur_f().stkdisp += 2;
                  curr_dynamic = true;
                  ++nvframes;
                  ADD_BIND (syms, fixint (0), ret);
                  ADD_BIND (syms, fixint (0), ret);
                }

              bc.emit (OPX_(LOAD0));   // Just a placeholder.
              bc.emit (OPX_(BIND), tmp);
              bc.cur_f().stkdisp += 2;
              ADD_BIND (syms, fixint (0), ret);
            }
          else
            {
              if (keyword_p (tmp))
                {
                  KP_VTRY (intern (interp, as_str (symname (tmp))),
                           interp->push (interp->retval));
                  tmp = interp->stktop ();
                }

              bc.emit (OPX_(LOAD0));
              ++bc.cur_f().nargs;
              curr_dynamic = false;
            }

          ADD_BIND (syms, tmp | (special_symbol_p (tmp) ? EXTRA_BIT : 0), ret);
        }
    }

  return (ret);
}

result<int> bc_compiler::compile_let (object env, bool tail, object expr)
{
  object bindings = xcar (expr);
  if (bindings == NIL)
    // 'let' with no bindings -> compile as a 'do' form.
    return (this->compile_do (env, tail, xcdr (expr)));

  cons sbody[2];
  int nargs = 0;
  auto ip = this->interp;

  if (!xcons_p (bindings))
    {
      if (!nksymbol_p (bindings) && !array_p (bindings))
        return (ip->raise ("arg-error",
                           KP_SPRINTF (ip, "let: invalid binding: %Q",
                                       bindings)));
      else if (!xcons_p (xcdr (expr)))
        return (ip->raise ("arg-error",
                           KP_SPRINTF (ip, "let: got a dotted list in the "
                                           "body: %Q", expr)));
      else if (xcdr (expr) == NIL)
        return (ip->raise ("arg-error", "missing body in let"));

      nargs = KP_TRY (count_bindings (ip, bindings));
      sbody[0].car = bindings;
      sbody[0].cdr = sbody[1].as_obj ();

      sbody[1].car = xcadr (expr);
      sbody[1].cdr = NIL;

      bindings = sbody[0].as_obj ();
      expr = xcdr (expr);
    }
  else
    for (object tmp = bindings; tmp != NIL; )
      {
        if (!nksymbol_p (xcar (tmp)) && !array_p (xcar (tmp)))
          return (ip->raise ("arg-error",
                             KP_SPRINTF (ip, "let: invalid binding: %Q",
                                         xcar (tmp))));

        nargs += KP_TRY (count_bindings (ip, xcar (tmp)));
        if (xcdr (tmp) == NIL)
          return (ip->raise ("arg-error",
                             KP_SPRINTF (ip, "let bindings must come in pairs, "
                                             "got: %Q", bindings)));
        else if (!xcons_p (xcdr (tmp)) || !xcons_p (tmp = xcddr (tmp)))
          return (ip->raise ("arg-error",
                             KP_SPRINTF (ip, "let bindings must not come in a "
                                             "dotted list: %Q", bindings)));
      }

  tmp_allocator ta { ip };
  cons *syms = (cons *)ta.alloc ((nargs + 2) * 8 * sizeof (*syms));
  cons *ctvs = syms + nargs * 4;
  cons t1, t2;
  int nctv = 0, nvframes = 0, nbinds = 0;
  bool curr_dynamic = false;

  // Link the lexical and compile-time environments.
  syms->car = syms->cdr = NIL;
  t1.car = syms->as_obj (), t1.cdr = env;

  ctvs->car = ctvs->cdr = NIL;
  t2.car = ctvs->as_obj (), t2.cdr = this->ct_env;
  this->ct_env = t2.as_obj ();

  nargs = count_let_nlex (bindings);
  this->push_f ();
  env = t1.as_obj ();

  for (; bindings != NIL; bindings = xcddr (bindings))
    {
      {
        int rv = KP_TRY (eval_ctv (*this, bindings, ctvs, nctv));
        if (rv >= 0)
          { /* This is a compile-time (i.e: macro or alias) definition,
             * rather than a lexical or dynamic binding. */
            nctv += 2;
            continue;
          }
      }

      object sym = xcar (bindings);

      if (array_p (sym))
        {
          object setf = find_sym (ip, "setf", 4);
          valref se (ip, fixint (0));

          if (!symbol_p (setf) ||
              !as_symbol(setf)->flagged_p (symbol::ctv_flag) ||
              !fct_p (*se = symval (setf)))
            return (ip->raise ("runtime-error", "let: setf is not bound"));

          nbinds += KP_TRY (flatten_array_args (*this, syms + nbinds, sym,
                                                curr_dynamic, nvframes));

          // Expand the (let [x y ...] (expr)) into (setf [x y ...] (expr))
          *se = KP_TRY (KP_CALL (ip, *se, xcar (bindings), xcadr (bindings)));
          KP_VTRY (this->compile_in (env, false, *se));
          this->emit (OPX_(POP));
          continue;
        }

      object evx = xcadr (bindings);

      if (kp_likely (!special_symbol_p (sym)))
        {
          KP_VTRY (this->compile_in (env, false, evx));
          ++this->cur_f().nargs;
          curr_dynamic = false;
        }
      else
        {
          if (!curr_dynamic)
            {
              this->emit (OPX_(VFRAME));
              this->cur_f().stkdisp += 2;
              curr_dynamic = true;
              ++nvframes;
              ADD_BIND (syms, fixint (0), nbinds);
              ADD_BIND (syms, fixint (0), nbinds);
            }

          KP_VTRY (this->compile_in (env, false, evx));
          this->emit (OPX_(BIND), sym);
          this->cur_f().stkdisp += 2;
          ADD_BIND (syms, fixint (0), nbinds);
        }

      ADD_BIND (syms, sym | (special_symbol_p (sym) ? EXTRA_BIT : 0), nbinds);
    }

  if (nctv)
    ctvs[nctv - 1].cdr = NIL;

  if (nbinds)
    syms[nbinds - 1].cdr = NIL;

  this->n_dbinds += nvframes;
  int r = KP_TRY (this->compile_do (env, tail && nvframes == 0, xcdr (expr)));
  this->ct_env = t2.cdr;

  if (nvframes)
    this->emit (OPX_(UNBIND), fixint (nvframes));

  if (nbinds && !evr_nlexit_p (r) && !tail)
    this->emit (OPX_(SKIP), fixint (nbinds));

  this->pop_f ();
  this->n_dbinds -= nvframes;
  return (r);
}

#undef ADD_BIND

result<object> compile_expr (interpreter *interp, object expr)
{
  bc_compiler bc (interp, bc_compiler::flg_toplevel);
  KP_VTRY (bc.compile_in (NIL, true, expr));
  bc.emit (OPX_(RET));

  valref ret = KP_TRY (alloc_fct (interp, function::artificial_flag));
  function *retp = as_fct (*ret);
  retp->bcode = bc.encode ();
  retp->vals = KP_TRY (bc.idxvec ());
  retp->max_sp = retp->max_stack ();
  return (*ret);
}

static result<object>
macroexp_atom (interpreter *interp, object env, object sym)
{
  object s2 = sym;

  if (nksymbol_p (s2) && (s2 = lookup_alias (env, sym)) == sym &&
      (as_symbol(s2)->flagged_p (symbol::alias_flag)))
    s2 = symval (s2);

  kp_return (s2);
}

static result<object>
macroexp_cons (interpreter *interp, object env, object expr)
{
  object x, h = xcar (expr);

  if (!symbol_p (h))
    kp_return (expr);
  else if ((x = lookup_ctv (env, h)) == h)
    {
      if (!as_symbol(h)->flagged_p (symbol::ctv_flag) ||
          !fct_p (interp->retval = symval (h)))
        kp_return (expr);
     
      x = interp->retval;
    }

  uint32_t n = 0;

  KP_VTRY (interp->push (x));
  for (expr = xcdr (expr); expr != NIL; expr = xcdr (expr), ++n)
    {
      if (!xcons_p (expr))
        return (interp->raise ("arg-error", "macro expasion requires "
                                            "a proper list as arguments"));

      KP_VTRY (macroexp_atom (interp, env, xcar (expr)),
               interp->push (interp->retval));
    }

  KP_TRY (call_n (interp, n));
  return (interp->retval);
}

result<object> macroexp_1 (interpreter *interp, object expr, object env)
{
  return ((xcons_p (expr) ? macroexp_cons : macroexp_atom) (interp, env, expr));
}

result<object> macroexp (interpreter *interp, object expr, object env)
{
  valref p (interp, expr);
  while (true)
    {
      *p = KP_TRY (macroexp_1 (interp, expr, env));
      if (expr == *p)
        kp_return (*p);

      expr = *p;
    }
}

result<object> compile_pkg (interpreter *interp, reader& rd)
{
  bc_compiler::ctable_t ctable;
  raw_acc<bvector> bytecode;
  raw_acc<array> fvals;
  valref expr (interp, NIL);
  valref ret = KP_TRY (alloc_fct (interp, function::artificial_flag));
  function *retp = as_fct (*ret);

  KP_VTRY (interp->growstk (1));
  for (ctable.cmp.ip = interp ; ; )
    {
      *expr = KP_TRY (rd.read_sexpr ());
      if (*expr == EOS)
        break;

      *expr = KP_TRY (macroexp (interp, *expr));

      bc_compiler bc (interp, bc_compiler::flg_toplevel |
                              bc_compiler::flg_warnings);
      ctable.swap (bc.ctable);
      KP_VTRY (bc.compile_in (NIL, false, *expr));
      bc.code.push_back (OPX_(RET));

      retp->bcode = bc.encode(false)->as_obj ();
      retp->name = retp->env = NIL;

      fvals.expand (bc.ctable.len ());
      retp->vals = bc.idxvec (fvals.as_obj ());
      retp->max_sp = retp->max_stack ();

      *interp->stkend++ = *ret;
      KP_VTRY (call_n (interp, 0));

      // Add a 'POP' instruction to mantain the stack size consistent.
      bvector *bvp = as_bvector (retp->bcode);
      bvp->data[bvp->nbytes - 1] = OP_POP;
      bytecode.add_data (bvp->data, bvp->nbytes);

      ctable.swap (bc.ctable);
    }

  unsigned char ret_code[] = { OP_RET };
  bytecode.add_data (ret_code, 1);

  retp->bcode = bytecode.release()->as_obj ();
  as_varobj(retp->bcode)->vo_full |= FLAGS_CONST;
  gc_register (interp, as_varobj (retp->bcode),
               sizeof (bvector) + bytecode.alloc);

  retp->vals = fvals.release()->as_obj ();
  as_varobj(retp->vals)->vo_full |= array::nonref_flag;
  gc_register (interp, as_varobj (retp->vals),
               sizeof (array) + fvals.alloc);

  retp->max_sp = retp->max_stack ();
  kp_return (*ret);
}

KP_DECLS_END
